home *** CD-ROM | disk | FTP | other *** search
Text File | 1997-06-17 | 5.1 KB | 189 lines | [TEXT/ALFA] |
- # init.tcl --
- #
- # Default system startup file for Tcl-based applications. Defines
- # "unknown" procedure and auto-load facilities.
- #
- # $Header: /rel/cvsfiles/devo/tcl/library/init.tcl,v 1.2 1992/12/23 15:39:29 zoo Exp $ SPRITE (Berkeley)
- #
- # Copyright 1991-1992 Regents of the University of California
- # Permission to use, copy, modify, and distribute this
- # software and its documentation for any purpose and without
- # fee is hereby granted, provided that this copyright
- # notice appears in all copies. The University of California
- # makes no representations about the suitability of this
- # software for any purpose. It is provided "as is" without
- # express or implied warranty.
- #
-
- # unknown:
- # Invoked when a Tcl command is invoked that doesn't exist in the
- # interpreter:
- #
- # 1. See if the autoload facility can locate the command in a
- # Tcl script file. If so, load it and execute it.
- # 2. See if the command exists as an executable UNIX program.
- # If so, "exec" the command.
- # 3. If the command was invoked at top-level:
- # (a) see if the command requests csh-like history substitution
- # in one of the common forms !!, !<number>, or ^old^new. If
- # so, emulate csh's history substitution.
- # (b) see if the command is a unique abbreviation for another
- # command. If so, invoke the command.
-
- proc unknown args {
- global auto_noload env unknown_pending;
-
- set name [lindex $args 0]
-
- if {[string length [set f [findCmd $name]]]} {
- uplevel #0 source [list $f]
- return [uplevel $args]
- } else {
- error "No such function: $name"
- }
- }
-
- # auto_mkindex:
- # Regenerate a tclIndex file from Tcl source files. Takes two arguments:
- # the name of the directory in which the tclIndex file is to be placed,
- # and a glob pattern to use in that directory to locate all of the relevant
- # files.
- proc auto_mkindex {dir files} {
- global alphaLite
-
- set oldDir [pwd]
- cd $dir
- append line "# Tcl autoload index file: each line identifies a file (nowrap)\n\n"
- append line "set [file tail [string trim [pwd] :]]_index \{\n"
-
- set cid [scancontext create]
- scanmatch $cid {^proc[ ]} {
- if {[regexp {^proc[ ]+([^ ]*)} $matchInfo(line) match procName]} {
- append line "$procName "
- }
- }
-
- foreach file [glob $files] {
- if {($file == "menusLite.tcl") && !$alphaLite} continue;
- watchCursor
- set f ""
- append line "\{[file tail $file] "
- message [file tail $file]
- set fid [open $file]
- scanfile $cid $fid
- close $fid
- append line "\}\n"
- }
-
- scancontext delete $cid
-
- append line "\}\n"
- set f [open tclIndexx w]
- puts $f $line nonewline
- close $f
- cd $oldDir
-
- foreach i [info vars {*_index}] {
- global $i
- unset $i
- }
- }
-
- proc findCmd cmd {
- global global auto_path
-
- foreach path $auto_path {
- if {![file exists $path]} continue
- set index "[file tail $path]_index"
- global $index
- if {![info exists $index]} {
- uplevel #0 source [list "$path:tclIndexx"]
- }
- if {[regexp "\{(\\w+.tcl)\[^\}\]* [quoteExpr $cmd] " [set $index] dummy file]} {
- return "$path:$file"
- }
- }
- }
-
-
- #================================================================================
- # Wonderful procs from Vince Darley (vince@das.harvard.edu).
- #===============================================================================
-
- proc traceTclProc {} {
- global tclMenu
- if {[llength [traceFunc status]]>2} {
- catch {markMenuItem $tclMenu {traceTclProc…} off}
- catch {enableMenuItem $tclMenu dumpTraces off}
- if {[string length [set data [traceDump]]]} {
- if {[askyesno "Dump traces?"] == "yes"} {
- dumpTraces [string trimright [lindex [traceFunc status] 3] {,}] $data
- setWinInfo dirty 0
- }
- }
- traceFunc off
- message "Tracing off."
- return
- }
- if {[llength [winNames]] && [string length [set sel [getSelect]]]} {
- set func [listpick -L $sel -p {Func Name:} [lsort -ignore [info procs]]]
- } else {
- set func [listpick -p {Func Name:} [lsort -ignore [info procs]]]
- }
- if {![string length $func]} return
- traceFunc on $func ""
- catch {markMenuItem $tclMenu {traceTclProc…} on}
- catch {enableMenuItem $tclMenu dumpTraces on}
- message "Tracing '$func'…"
- }
-
-
- proc dumpTraces {{name ""} {data ""}} {
- if {![string length $name]} {
- set name [string trimright [lindex [traceFunc status] 3] {,}]
- }
- if {![string length $data]} {
- set data [traceDump]
- }
-
- if {![string length $data]} {
- message "Trace buffer empty"
- } else {
- regsub -all {:} $name {.} name
- new -n "* Trace '$name' *"
- insertText $data
- setWinInfo dirty 0
- goto 0
- }
- }
-
-
- proc rebuildTclIndices {} {
- global auto_path
- set d [pwd]
- # do we really need the next line? Alpha's original uses it.
- cd
- foreach dir $auto_path {
- # if directory exists
- if { ![catch { cd $dir } ] } {
- # if there are any files
- if { ![catch { glob *.*tcl } ] } {
- message "Building [file tail $dir] index…"
-
- # if the '[incr tcl]' version exists, use that
- # use 'catch' also in case directory is write-protected
- if [catch { itcl_mkindex : *.*tcl } ] {
- # else try the normal one
- catch { auto_mkindex : *.*tcl }
- }
- }
- }
- }
- # redo the auto-mode-file connections (see "smarterSource.tcl")
- message "Building the mode-file dependency array"
- catch {autoModeFiles}
- message ""
- cd $d
- }
-
-